home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / ABUSESRC.ZIP / AbuseSrc / abuse / src / lisp_gc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-04-11  |  6.7 KB  |  267 lines
  1. /*  Lisp garbage collections :  uses copy/free algorithm
  2.     Places to check :
  3.       symbol 
  4.         values
  5.     functions
  6.     names
  7.       stack
  8.  
  9.  
  10.       
  11.  
  12. */
  13. #include <stdlib.h>
  14. #include "lisp.hpp"
  15.  
  16. #ifdef NO_LIBS
  17. #include "fakelib.hpp"
  18. #else
  19. #include "jmalloc.hpp"
  20. #include "macs.hpp"
  21. #endif
  22.  
  23. #include "stack.hpp"
  24. #include <string.h>
  25.  
  26.  
  27. grow_stack<void> l_user_stack(600);       // stack user progs can push data and have it GCed
  28. grow_stack<void *> l_ptr_stack(6000);         // stack of user pointers, user pointers get remapped on GC
  29.  
  30. int reg_ptr_total=0;
  31. int reg_ptr_list_size=0;
  32. void ***reg_ptr_list=NULL;
  33.  
  34. void register_pointer(void **addr)
  35. {
  36.   if (reg_ptr_total>=reg_ptr_list_size)
  37.   {
  38.     reg_ptr_list_size+=0x100;
  39.     reg_ptr_list=(void ***)jrealloc(reg_ptr_list,sizeof(void **)*reg_ptr_list_size,"registered ptr list");
  40.   }
  41.   reg_ptr_list[reg_ptr_total++]=addr;
  42. }
  43.  
  44.  
  45. void unregister_pointer(void **addr)
  46. {
  47.   int i;
  48.   void ***reg_on=reg_ptr_list;
  49.   for (i=0;i<reg_ptr_total;i++,reg_on++)
  50.   {
  51.     if (*reg_on==addr)
  52.     {
  53.       int j;
  54.       reg_ptr_total--;
  55.       for (j=i;j<reg_ptr_total;j++,reg_on++)
  56.         reg_on[0]=reg_on[1];      
  57.       return ;
  58.     }
  59.   }
  60.   fprintf(stderr,"Unable to locate ptr to unregister");
  61. }
  62.  
  63. static void *collect_object(void *x);
  64. static void *collect_array(void *x)
  65. {
  66.   long s=((lisp_1d_array *)x)->size;
  67.   lisp_1d_array *a=new_lisp_1d_array(s,NULL);
  68.   void **src,**dst;
  69.   src=(void **)(((lisp_1d_array *)x)+1);
  70.   dst=(void **)(a+1);
  71.   for (int i=0;i<s;i++)
  72.     dst[i]=collect_object(src[i]);
  73.  
  74.   return a;
  75. }
  76.  
  77. static uchar *cstart,*cend,*collected_start,*collected_end;
  78.  
  79. inline void *collect_cons_cell(void *x)
  80. {
  81.   cons_cell *last=NULL,*first;
  82.   if (!x) return x;
  83.   for (;x && item_type(x)==L_CONS_CELL;)
  84.   {
  85.     cons_cell *p=new_cons_cell();
  86.     void *old_car=((cons_cell *)x)->car;
  87.     void *old_cdr=((cons_cell *)x)->cdr;
  88.     void *old_x=x;
  89.     x=CDR(x);
  90.     ((lisp_collected_object *)old_x)->type=L_COLLECTED_OBJECT;
  91.     ((lisp_collected_object *)old_x)->new_reference=p;
  92.  
  93.     p->car=collect_object(old_car); 
  94.     p->cdr=collect_object(old_cdr); 
  95.       
  96.     if (last) last->cdr=p;
  97.     else first=p;
  98.     last=p;
  99.   }
  100.   if (x)
  101.     last->cdr=collect_object(x);
  102.   return first;                    // we already set the collection pointers
  103. }
  104.  
  105. static void *collect_object(void *x)
  106. {
  107.   void *ret=x;
  108.  
  109.   if (((uchar *)x)>=cstart && ((uchar *)x)<cend)
  110.   {
  111.     switch (item_type(x))
  112.     {
  113.       case L_BAD_CELL :
  114.       { lbreak("error : GC corrupted cell\n"); } break;
  115.  
  116.       case L_NUMBER : 
  117.       { ret=new_lisp_number(((lisp_number *)x)->num); } break;
  118.  
  119.  
  120.       case L_SYS_FUNCTION :
  121.       { ret=new_lisp_sys_function( ((lisp_sys_function *)x)->min_args,
  122.                       ((lisp_sys_function *)x)->max_args,
  123.                       ((lisp_sys_function *)x)->fun_number);
  124.       } break;
  125.       case L_USER_FUNCTION :
  126.       {
  127. #ifndef NO_LIBS
  128.     ret=new_lisp_user_function( ((lisp_user_function *)x)->alist,
  129.                        ((lisp_user_function *)x)->blist);
  130.  
  131. #else
  132.     void *arg=collect_object(((lisp_user_function *)x)->arg_list);
  133.     void *block=collect_object(((lisp_user_function *)x)->block_list);
  134.     ret=new_lisp_user_function(arg,block);
  135. #endif
  136.       } break;
  137.       case L_STRING :
  138.       { ret=new_lisp_string(lstring_value(x)); } break;
  139.  
  140.       case L_CHARACTER :
  141.       { ret=new_lisp_character(lcharacter_value(x)); } break; 
  142.  
  143.       case L_C_FUNCTION :
  144.       {
  145.     ret=new_lisp_c_function( ((lisp_sys_function *)x)->min_args,
  146.                       ((lisp_sys_function *)x)->max_args,
  147.                       ((lisp_sys_function *)x)->fun_number);
  148.       } break;
  149.  
  150.       case L_C_BOOL :
  151.       {
  152.     ret=new_lisp_c_bool( ((lisp_sys_function *)x)->min_args,
  153.                       ((lisp_sys_function *)x)->max_args,
  154.                       ((lisp_sys_function *)x)->fun_number);
  155.       } break;
  156.       case L_L_FUNCTION :
  157.       {
  158.     ret=new_user_lisp_function( ((lisp_sys_function *)x)->min_args,
  159.                       ((lisp_sys_function *)x)->max_args,
  160.                       ((lisp_sys_function *)x)->fun_number);
  161.       } break;
  162.  
  163.       case L_POINTER :
  164.       { ret=new_lisp_pointer(lpointer_value(x)); } break;
  165.       
  166.  
  167.       case L_1D_ARRAY :
  168.       { ret=collect_array(x); } break;
  169.  
  170.       case L_FIXED_POINT :
  171.       { ret=new_lisp_fixed_point(lfixed_point_value(x)); } break;
  172.  
  173.       case L_CONS_CELL :
  174.       { ret=collect_cons_cell((cons_cell *)x); } break;
  175.  
  176.       case L_OBJECT_VAR :
  177.       {
  178.     ret=new_lisp_object_var( ((lisp_object_var *)x)->number);
  179.       } break;
  180.       case L_COLLECTED_OBJECT :
  181.       {
  182.     ret=((lisp_collected_object *)x)->new_reference;
  183.       } break;
  184.  
  185.       default :
  186.       { lbreak("shouldn't happen. collecting bad object\n"); } break;      
  187.     }
  188.     ((lisp_collected_object *)x)->type=L_COLLECTED_OBJECT;
  189.     ((lisp_collected_object *)x)->new_reference=ret;
  190.   } else if ((uchar *)x<collected_start || (uchar *)x>=collected_end)  
  191.   {
  192.     if (item_type(x)==L_CONS_CELL) // still need to remap cons_cells outside of space
  193.     {
  194.       for (;x && item_type(x)==L_CONS_CELL;x=CDR(x))
  195.         ((cons_cell *)x)->car=collect_object(((cons_cell *)x)->car);
  196.       if (x)
  197.         ((cons_cell *)x)->cdr=collect_object(((cons_cell *)x)->cdr);
  198.     }
  199.   }
  200.  
  201.   return ret;
  202. }
  203.  
  204. static void collect_symbols(lisp_symbol *root)
  205. {
  206.   if (root)
  207.   {
  208.     root->value=collect_object(root->value);
  209.     root->function=collect_object(root->function);
  210.     root->name=collect_object(root->name);
  211.     collect_symbols(root->left);
  212.     collect_symbols(root->right);
  213.   }
  214. }
  215.  
  216. static void collect_stacks()
  217. {
  218.   long t=l_user_stack.son;
  219.   void **d=l_user_stack.sdata;
  220.   int i=0;
  221.   for (;i<t;i++,d++)
  222.     *d=collect_object(*d);
  223.  
  224.   t=l_ptr_stack.son;
  225.   void ***d2=l_ptr_stack.sdata;
  226.   for (i=0;i<t;i++,d2++)
  227.   {
  228.     void **ptr=*d2;
  229.     *ptr=collect_object(*ptr);
  230.   }
  231.  
  232.   d2=reg_ptr_list;
  233.   for (t=0;t<reg_ptr_total;t++,d2++)
  234.   {
  235.     void **ptr=*d2;
  236.     *ptr=collect_object(*ptr);
  237.   }    
  238.  
  239. }
  240.  
  241. void collect_space(int which_space) // should be tmp or permenant
  242. {
  243.   int old_space=current_space;
  244.   cstart=(uchar *)space[which_space];
  245.   cend=(uchar *)free_space[which_space];
  246.  
  247.   space_size[GC_SPACE]=space_size[which_space];
  248.   void *new_space=jmalloc(space_size[GC_SPACE],"collect lisp space");
  249.   current_space=GC_SPACE;
  250.   free_space[GC_SPACE]=space[GC_SPACE]=(char *)new_space;
  251.  
  252.   collected_start=(uchar *)new_space;
  253.   collected_end=(((uchar *)new_space)+space_size[GC_SPACE]);
  254.  
  255.   collect_symbols(lsym_root);
  256.   collect_stacks();
  257.  
  258.   memset(space[which_space],0,space_size[which_space]);  // for debuging clear it out
  259.   jfree(space[which_space]);
  260.  
  261.   space[which_space]=(char *)new_space;
  262.   free_space[which_space]=((char *)new_space)+
  263.          (((uchar *)free_space[GC_SPACE])-((uchar *)space[GC_SPACE]));
  264.   current_space=old_space;
  265. }
  266.  
  267.